functor Machine (S : MACHINE_STRUCTS) : MACHINE =
struct
  open S

  structure T = Types
  structure Id = Id
  
  structure IdSet =
  struct
  structure Set = BinarySetFn (struct
                                        type ord_key = Id.t
                                        val compare = Id.compare
                                      end)
  
  type t = Set.set
  
  fun fromList (l : Id.t list) : t = Set.addList (Set.empty, l)
  val empty = Set.empty
  val equals = Set.equal
  val difference = Set.difference
  val toList = Set.listItems
  fun toString x = String.concat (List.map (fn y => String.concat [Id.toString y, " "]) (toList x))
  val union = Set.union
  end
  
  structure Interval =
  struct
    type t = {low : Counter.t, high : Counter.t}
    
    fun bogus () = {low = Counter.max (), high = Counter.min ()}
    
    fun expire ({low = l1, high = h1}, {low = l2, high = h2}) =
        case Counter.compare (h1, l2)
         of LESS => true
          | _ => false
    
    fun headCompare ({low = l1, high = h1}, {low = l2, high = h2}) =
        Counter.compare (l1, l2)
        
    fun tailCompare ({low = l1, high = h1}, {low = l2, high = h2}) =
        Counter.compare (h1, h2)
    
    fun shrink (x as {low, high}, c) =
        let val (r1, r2) = (Counter.compare (c, low), Counter.compare (c, high))
        in  case (r1, r2)
             of (LESS, LESS) => {low = c, high = high}
              | (LESS, GREATER) => {low = c, high = c}
              | (LESS, EQUAL) => {low = c, high = high}
              | (EQUAL, LESS) => x
              | (EQUAL, EQUAL) => x
              | (EQUAL, GREATER) => {low = low, high = c}
              | (GREATER, LESS) => x
              | (GREATER, EQUAL) => x
              | (GREATER, GREATER) => {low = low, high = c} 
        end
        
    fun toString {low, high} =
        String.concat ["[", Counter.toString low, ", ", Counter.toString high, "]"] 
  end
  
  structure Register =
  struct
    datatype t
      = eax | ebx | ecx | edx | esi | edi | ebp | esp
    
    fun allocatables () =
        [ecx, edx, esi, edi]
        
    fun toString t =
        case t
         of eax => " eax "
          | ebx => " ebx "
          | ecx => " ecx "
          | edx => " edx "
          | esi => " esi "
          | edi => " edi "
          | ebp => " ebp "
          | esp => " esp "
  end
  
  structure Location =
  struct
    datatype t
      = InStack of Intl.t
      | InReg of Register.t
      | Global
      | NoWhere
      
    fun bogus () = NoWhere
    
    fun toString t =
        case t
         of InStack i => Intl.toString2 i
          | InReg r => Register.toString r
          | Global => raise Fail "to do"
          | NoWhere => "no where"
  end
  
  val tag = false
  fun debugPrint s =
      if tag
      then print s
      else ()
      
  fun printList (l, separator, ToStr) =
      let fun f x = String.concat [x, separator]
      in  String.concat (List.map (f o ToStr) l)
      end
      
  fun printListPhi (l, ToStr) =
      case l 
       of [] => ""
        | {operand, from} :: xs =>
          String.concat ["(", ToStr operand, ", ", Id.toString from, "), ", printListPhi (xs, ToStr)]
     
  fun printListDot (l, separator, toStr) =
      case l
       of [] => ""
        | x :: xs =>
          String.concat [toStr x, "\\n", printListDot (xs, separator, toStr)]

  fun listFields fields =
      case fields
          of [] => ""
           | [{id, ty}] =>
             String.concat [Types.toString ty, " ", Id.toString id, ";\n"]
           | {id, ty}::flds =>
             String.concat [Types.toString ty, " ", Id.toString id, ";\n", listFields flds]
             
  fun listLocals fields =
      case fields
          of [] => ""
           | [{id, loc, ty}] =>
             String.concat [Types.toString ty, " ",
                            Id.toString id, " loc=", Location.toString loc, ";\n"]
           | {id, loc, ty} :: xs =>
             String.concat [Types.toString ty, " ",
                            Id.toString id, " loc=", Location.toString loc, ";\n", listLocals xs]
             
  fun listArgs args =
      case args
          of [] => ""
           | [{id, loc, ty}] => 
             String.concat [Types.toString ty, " ", Id.toString id]
           | {id, loc, ty} :: flds =>
             String.concat [Types.toString ty, " ", Id.toString id, ", ", listArgs flds]

  structure Binop =
  struct
    datatype t
      = Plus
      | Minus
      | Times
      | Divide
      | Modus
      | Not
      | And
      | Or
      | Eq
      | Ne
      | Gt
      | Ge
      | Lt
      | Le

    fun equals (x1, x2) = x1 = x2

    fun toString x =
        case x
         of Plus => " + "
          | Minus => " - "
          | Times => " * "
          | Divide => " / "
          | Modus => " % "
          | Not => " ! "
          | And => " && "
          | Or => " || "
          | Eq => " == "
          | Ne => " != "
          | Gt => " > "
          | Ge => " >= "
          | Lt => " < "
          | Le => " <= "
  end

  

  structure Operand =
  struct
    datatype t
      = OpVoid
      | IntNum of Intl.t
      | Var of {id : Id.t, ty : Types.t}
      | True
      | False
      | Null
      | Mem of {id : Id.t, ty : Types.t}
      | Reg of {reg: Register.t, ty : Types.t}

    fun orig t =
        case t
         of Var {id, ...} => [id]
          | Mem {id, ...} => [id]
          | _ => []
(*    
    fun substId (t, subst) =
        case t
         of Var {id, ty} =>
            let val newId = (subst id)
                           handle (EmptyStack ) => raise Fail (Id.toString id)
                val _ = debugPrint (String.concat ["\n", Id.toString id, " ===> ", Id.toString newId, "\n"])
            in  Var {id = newId, ty = ty}
            end
          | Mem {id, ty} => Mem {id = subst id, ty = ty}
          | _ => t
          
    fun substDestId (t, subst) =
        case t
         of Var {id, ty} =>
            let val newId = (subst id)
                           handle (EmptyStack ) => raise Fail (Id.toString id)
                val _ = debugPrint (String.concat ["\n", Id.toString id, " ===> ", Id.toString newId, "\n"])
            in  Var {id = newId, ty = ty}
            end
          | Mem {id, ty} => Mem {id = subst id, ty = ty}
          | _ => t
    
    fun substConst (t, origId, v) =
        case t
         of Var {id, ty} =>
            if Id.equals (id, origId)
            then v
            else t
          | Mem {id, ty} =>
            if Id.equals (id, origId)
            then v
            else t
          | _ => t
    
    fun dest t = 
        case t
         of OpVoid => raise Fail "compiler bug\n"
          | IntNum i => raise Fail "compiler bug\n"
          | Var {id, ty} => SOME id
          | True => raise Fail "compiler bug\n"
          | False => raise Fail "compiler bug\n"
          | Null => raise Fail "compiler bug\n"
          | Mem {id, ty} => NONE
    
    fun isConst t =
        case t
         of OpVoid => true
          | IntNum _ => true
          | Var _ => false
          | True => true
          | False => true
          | Null => true
          | Mem _ => false
  *)        
    fun isVar t =
        case t
         of Var _ => true
          | _ => false
    (*      
    fun getVar t =
        if isVar t
        then SOME t
        else NONE
    
    fun getConst t =
        if isConst t
        then SOME t
        else NONE
        
    fun getOneConst t =
        case t
         of [] => raise Fail "compiler bug"
          | x :: _ => x
          
    fun getOneVar t =
        case t
         of [] => raise Fail "compiler bug"
          | x :: _ =>
            if isVar x
            then x
            else raise Fail "compiler bug"
          
    fun isConsts t =
        case t
         of [] => true
          | x :: xs =>
            if isConst x
            then isConsts xs
            else false
    
    fun equals (x, y) =
        case (x, y)
         of (OpVoid, OpVoid) => true
          | (IntNum i1, IntNum i2) => Intl.equals (i1, i2)
          | (Var {id = id1, ty = ty1}, Var {id = id2, ty = ty2}) =>
            Id.equals (id1, id2)
          | (True, True) => true
          | (False, False) => true
          | (Null, Null) => true
          | (Mem {id = id1, ty = ty1}, Mem {id = id2, ty = ty2}) =>
            Id.equals (id1, id2)
          | _ => false
            
    fun isConstsAndEqual t =
        case t
         of [] => true
          | [x] => isConst x
          | x :: y :: xs =>
            if (isConst x) andalso (isConst y) andalso equals (x, y) 
            then isConstsAndEqual (y :: xs)
            else false
                
*)
    
    fun isMem t =
        case t
         of Mem _ => true
          | _ => false
  (*  
    fun isZero t =
        case t
         of IntNum i => Intl.isZero i
          | _ => false
*)
    fun toString t =
        case t
         of OpVoid => " () "
          | IntNum i => Intl.toString i
          | Var {id, ty} => Id.toString id
          | True => " true "
          | False => " false "
          | Null => " null "
          | Mem {id, ty} => String.concat [" $mem(", Id.toString id,")"] 
          | Reg {reg, ty} => Register.toString reg
  end

  structure Stm =
  struct
    datatype t
      = Assign of {line : Counter.t, dest : Operand.t, src : Operand.t, ty : Types.t}
      | AssignExp of {line : Counter.t, dest : Operand.t, bop : Binop.t, src : Operand.t list, ty : Types.t}
      | Alloc of {line : Counter.t, fid: Id.t, ty : Types.t}
      | Call of {line : Counter.t, fid : Id.t, src : Operand.t list, ty : Types.t}
      
    fun gen t =
        case t
         of Assign {line, dest, src, ty} =>
            let val ids = if Operand.isMem dest
                          then Operand.orig dest
                          else []
                val src = Operand.orig src
            in  ids @ src
            end
          | AssignExp {line, dest, bop, src, ty} =>
            let val ids = if Operand.isMem dest
                          then Operand.orig dest
                          else []
                val src = List.concat (List.map Operand.orig src)
            in  ids @ src
            end
          | Call {line, fid, src, ty} =>
            List.concat (List.map Operand.orig src)
          | Alloc {line, fid, ty} => []
            
    fun kill t =
        case t
         of Assign {line, dest, src, ty} =>
            let val id = if Operand.isVar dest
                         then Operand.orig dest
                         else []
            in  id
            end
          | AssignExp {line, dest, bop, src, ty} =>
            let val id = if Operand.isVar dest
                         then Operand.orig dest
                         else []
            in  id
            end
          | Call {line, fid, src, ty} => []            
          | Alloc {line, fid, ty} => []
          
    fun line t =
        case t
         of Assign {line, ...} => line
          | AssignExp {line, ...} => line
          | Call {line, ...} => line            
          | Alloc {line, ...} => line
(*
    val bogus = fn _ => raise Fail "bogus"
    val equals = fn _ => raise Fail "bogus"
    val equalsStms = fn _ => raise Fail "bogus"
    
    fun getPhiOperand (src : {operand : Operand.t, from : Id.t} list) = List.map #operand src
    
    fun getPhiSrc s =
        case s
         of Phi {line, dest, src} => getPhiOperand src
          | _ => raise Fail "compiler bug"
          
    fun isPhi s =
        case s
         of Phi _ => true
          | _ => false
     
    fun isAssignMem s =
        case s
         of Assign {line, dest, src, ty} => Operand.isMem dest
          | AssignExp {line, dest, bop, src, ty} => Operand.isMem dest
          | AssignCall {line, dest, src} => Operand.isMem dest
          | Call {line, fid, src} => false
          | Exp {line, src} => false
          | Alloc {line, ty, dest} => Operand.isMem dest
          | Free {line, src, ty} => false
          | Label {id} => raise Fail "compiler bug"
          | Phi {line, dest, src} => Operand.isMem dest
          | _ => raise Fail "compiler bug"
          
    fun orig s =
        case s
         of Assign {dest, ...} => Operand.orig dest
          | AssignExp {dest, ...} => Operand.orig dest
          | AssignCall {dest, ...} => Operand.orig dest
          | Alloc {dest, ...} => Operand.orig dest
          | _ => []
    
    fun cookDest s =
        case s
         of Assign {line, dest, src, ty} =>
            Operand.dest dest
          | AssignExp {line, dest, bop, src, ty} =>
            Operand.dest dest
          | AssignCall {line, dest, src} =>
            Operand.dest dest
          | Call {line, fid, src} =>
            NONE
          | Exp {line, src} => NONE
          | Alloc {line, ty, dest} => Operand.dest dest
          | Free {line,src,ty} => NONE
          | Label {id} => raise Fail "compiler bug"
          | Phi {line, dest, src} => Operand.dest dest
          | _ => raise Fail "compiler bug"
    
    fun substDest (t, subst) =
        case t
         of Assign {line, dest, src, ty} =>
            Assign {line = line,
                    dest = Operand.substDestId (dest, subst),
                    src = src,
                    ty = ty}
          | AssignExp {line, dest, bop, src, ty} =>
            AssignExp {line = line,
                       dest = Operand.substDestId (dest, subst),
                       bop = bop,
                       src = src,
                       ty = ty}
          | AssignCall {line, dest, src} =>
            AssignCall {line = line,
                        dest = Operand.substDestId (dest, subst),
                        src = src}
          | Call {line, fid, src} =>
            Call {line = line,
                  fid = fid,
                  src = src}
          | Exp {line, src} =>
            Exp {line = line,
                 src = src}
          | Alloc {line, ty, dest} =>
            Alloc {line = line,
                   dest = Operand.substDestId (dest, subst),
                   ty = ty}
          | Free {line, src, ty} =>
            Free {line = line,
                  src = src,
                  ty = ty}
          | Label {id} => Label {id = id}
          | Phi {line, dest, src} =>
            Phi {line = line,
                 dest = Operand.substDestId (dest, subst),
                 src = src}
          | _ => raise Fail "compiler bug"
          
    fun substPhi (t, topStack, n) =
        case t
         of Phi {line, dest, src} =>
            let fun subst (l, n) =
                    case (l, n)
                     of ([], _) => raise Fail "compiler bug"
                      | ({operand, from} :: xs, n) => 
                        if Id.equals (from, n)
                        then {operand = Operand.substId (operand, topStack), from = from} :: xs
                        else {operand = operand, from = from} :: (subst (xs, n))
                val newSrc = subst (src, n)
                val new = Phi {line = line, dest = dest, src = newSrc}
            in  new
            end
          | _ => t
                
    fun substUses (t, subst) =
        case t
         of Assign {line, dest, src, ty} =>
            Assign {line = line,
                    dest = dest,
                    src = Operand.substId (src, subst),
                    ty = ty}
          | AssignExp {line, dest, bop, src, ty} =>
            AssignExp {line = line,
                       dest = dest,
                       bop = bop,
                       src = List.map (fn mm => Operand.substId (mm, subst)) src,
                       ty = ty}
          | AssignCall {line, dest, src} =>
            AssignCall {line = line,
                        dest = dest,
                        src = List.map (fn mm => Operand.substId (mm, subst)) src}
          | Call {line, fid, src} =>
            Call {line = line,
                  fid = fid,
                  src = List.map (fn mm => Operand.substId (mm, subst)) src}
          | Exp {line, src} =>
            Exp {line = line,
                 src = Operand.substId (src, subst)}
          | Alloc {line, ty, dest} =>
            Alloc {line = line,
                   dest = dest,
                   ty = ty}
          | Free {line,src,ty} =>
            Free {line = line,
                  src = Operand.substId (src, subst),
                  ty = ty}
          | Label {id} => Label {id = id}
          | Phi {line, dest, src} =>
            raise Fail "compiler bug, this function should not be called for this case\n"
          | _ => raise Fail "compiler bug"
          
    fun substCopyPropUses (t, subst) =
        case t
         of Assign {line, dest, src, ty} =>
            Assign {line = line,
                    dest = dest,
                    src = Operand.substId (src, subst),
                    ty = ty}
          | AssignExp {line, dest, bop, src, ty} =>
            AssignExp {line = line,
                       dest = dest,
                       bop = bop,
                       src = List.map (fn mm => Operand.substId (mm, subst)) src,
                       ty = ty}
          | AssignCall {line, dest, src} =>
            AssignCall {line = line,
                        dest = dest,
                        src = List.map (fn mm => Operand.substId (mm, subst)) src}
          | Call {line, fid, src} =>
            Call {line = line,
                  fid = fid,
                  src = List.map (fn mm => Operand.substId (mm, subst)) src}
          | Exp {line, src} =>
            Exp {line = line,
                 src = Operand.substId (src, subst)}
          | Alloc {line, ty, dest} =>
            Alloc {line = line,
                   dest = dest,
                   ty = ty}
          | Free {line,src,ty} =>
            Free {line = line,
                  src = Operand.substId (src, subst),
                  ty = ty}
          | Label {id} => Label {id = id}
          | Phi {line, dest, src} =>
            Phi {line = line,
                 dest = dest,
                 src = List.map 
                       (fn {operand, from} => 
                           {operand = Operand.substId (operand, subst), from = from}) src}
          | _ => raise Fail "compiler bug"
          
    fun substConst (t, origId, v) =
        case t
         of Assign {line, dest, src, ty} =>
            Assign {line = line,
                    dest = dest,
                    src = Operand.substConst (src, origId, v),
                    ty = ty}
          | AssignExp {line, dest, bop, src, ty} =>
            AssignExp {line = line,
                       dest = dest,
                       bop = bop,
                       src = List.map (fn mm => Operand.substConst (mm, origId, v)) src,
                       ty = ty}
          | AssignCall {line, dest, src} =>
            AssignCall {line = line,
                        dest = dest,
                        src = List.map (fn mm => Operand.substConst (mm, origId, v)) src}
          | Call {line, fid, src} =>
            Call {line = line,
                  fid = fid,
                  src = List.map (fn mm => Operand.substConst (mm, origId, v)) src}
          | Exp {line, src} =>
            Exp {line = line,
                 src = Operand.substConst (src, origId, v)}
          | Alloc {line, ty, dest} =>
            Alloc {line = line,
                   dest = dest,
                   ty = ty}
          | Free {line, src, ty} =>
            Free {line = line,
                  src = Operand.substConst (src, origId, v),
                  ty = ty}
          | Label {id} => raise Fail "compiler bug"
          | Phi {line, dest, src} =>
            Phi {line = line,
                 dest = dest,
                 src = List.map (fn {operand, from} => 
                                   {operand = Operand.substConst (operand, origId, v), from = from}) src}
          | _ => raise Fail "compiler bug"
          

          
    fun uses s =
        case s
         of Assign {line, dest, src, ty} =>
            let val ids = if Operand.isMem dest
                          then Operand.orig dest
                          else []
            in  ids @ (Operand.orig src)
            end
          | AssignExp {line, dest, bop, src, ty} =>
            let val ids = if Operand.isMem dest
                          then Operand.orig dest
                          else []
            in  ids @ (List.concat (List.map Operand.orig src))
            end
          | AssignCall {line,dest,src} =>
            let val ids = if Operand.isMem dest
                          then Operand.orig dest
                          else []
            in  ids @ (List.concat (List.map Operand.orig src))
            end
          | Call {line, fid, src} =>
            List.concat (List.map Operand.orig src)
          | Exp {line, src} => Operand.orig src
          | Alloc {line, ty, dest} => []
          | Free {line, src, ty} => Operand.orig src
          | Label {id} => []
          | Phi {line, dest, src} =>
            let val ids = if Operand.isMem dest
                          then Operand.orig dest
                          else []
            in  ids @ (List.concat (List.map Operand.orig (List.map #operand src)))
            end
          | _ => raise Fail "compiler bug"
    
    fun usesId (s, id) =
        let val ids = uses s
        in  List.exists (fn x => Id.equals (x, id)) ids            
        end
        
    fun withSideEffects t =
        case t
         of Assign {line, dest, src, ty} => Operand.isMem dest
          | AssignExp {line, dest, bop, src, ty} => Operand.isMem dest
          | AssignCall {line, dest, src} => true
          | Call {line, fid, src} => true
          | Exp {line, src} => false
          | Alloc {line, ty, dest} => true
          | Free {line, src, ty} => true
          | Label {id} => raise Fail "compiler bug"
          | Phi {line, dest, src} => Operand.isMem dest
          | _ => raise Fail "compiler bug"
*)
    fun toString t =
        case t
         of Assign {line, dest, src, ty} =>
            String.concat [Counter.toString line, ": ", Operand.toString dest, "=", Operand.toString src]
          | AssignExp {line, dest, bop, src, ty} =>
            String.concat [Counter.toString line, ": ", Operand.toString dest, "=",Binop.toString bop,"(",
                          printList (src,",",Operand.toString), ")" ]
          | Call {line, fid, src, ty} =>
            String.concat [Counter.toString line, ": ", Id.toString fid,"(",printList (src,",",Operand.toString),")"]
          | Alloc {line, fid, ty} => 
            String.concat [Counter.toString line, ": ",  Id.toString fid, "(", Types.toString ty,")"]
  end

  structure Transfer =
  struct
    datatype t
      = Jump of {line : Counter.t, label : Id.t}
      | If of {line : Counter.t, value : Operand.t, truee : Id.t, falsee : Id.t}
      | Return of {line : Counter.t, value : Operand.t}
      
    fun gen x =
        case x
         of Jump {line, label} => []
          | If {line, value, truee, falsee} => Operand.orig value
          | Return {line, value} => Operand.orig value
          
    fun line x =
        case x
         of Jump {line, label} => line
          | If {line, value, truee, falsee} => line
          | Return {line, value} => line
(*
    fun bogus () = Jump {line = Counter.bogus (), label = Id.bogus ()}
    
    fun substUses (t, subst) =
        case t
         of x as Jump {line, label} => x
          | If {line, value, truee, falsee} =>
            If {line = line,
                value = Operand.substId (value, subst),
                truee = truee,
                falsee = falsee}
          | Return {line, value} =>
            Return {line = line,
                    value = Operand.substId (value, subst)}
    
    fun substConst (t, origId, v) =
        case t
         of x as Jump _ => x
          | If {line, value, truee, falsee} =>
            If {line = line,
                value = Operand.substConst (value, origId, v),
                truee = truee,
                falsee = falsee}
          | Return {line, value} =>
            Return {line = line,
                    value = Operand.substConst (value, origId, v)}

     
    fun uses t =
        case t
         of Jump _ => []
          | If {line, value, truee, falsee} => Operand.orig value
          | Return {line, value} => Operand.orig value          
          
    fun usesId (t, id) =
        let val ids = uses t
        in  List.exists (fn x => Id.equals (id, x)) ids
        end  
*)
                                   
    fun toString x =
        case x
         of Jump {line, label} => 
            String.concat [Counter.toString line, ": ", "Jump ", Id.toString label]
          | If {line, value, truee, falsee} =>
            String.concat [Counter.toString line, ": ", "IfJump (", Operand.toString value, ", ",
                           Id.toString truee, ", ",
                           Id.toString falsee, ")"]
          | Return {line, value} =>
            String.concat [Counter.toString line, ": ", "Return ", Operand.toString value]      
  end

  structure Block =
  struct
    datatype t
      = T of {name : Id.t,
              prop : bool,
              stms : Stm.t list,
              transfer : Transfer.t,
              successors : Id.t list}

    fun gen x =
        case x
          of T {name, prop, stms, transfer, successors} =>
             let val genTrans = Transfer.gen transfer
                 fun doit ss =
                     case ss
                      of [] => IdSet.fromList genTrans
                       | x :: xs =>
                         let val genB = doit xs
                             val killx = IdSet.fromList (Stm.kill x)
                             val genx = IdSet.fromList (Stm.gen x)
                         in  IdSet.union (IdSet.difference (genB, killx), genx)
                         end                     
             in  doit stms
             end
             
    fun kill x =
        case x
          of T {name, prop, stms, transfer, successors} =>
             let fun doit ss =
                     case ss
                      of [] => IdSet.empty
                       | x :: xs =>
                         let val killB = doit xs
                             val killx = IdSet.fromList (Stm.kill x)
                         in  IdSet.union (killB, killx)
                         end                     
             in  doit stms
             end
        
(*
    fun addStm (b, s) =
        case b
         of T {name, prop, stms, transfer, successors, ...} =>
            T {name = name,
               prop = prop,
               stms = s :: stms,
               transfer = transfer,
               successors = successors}
               
    fun equals (x1, x2) =
        case (x1, x2)
         of (T {name = n1, ...}, T {name = n2, ...}) =>
            Id.equals (n1, n2)
*)        
    fun name (T {name, ...}) = name
(*    
    fun removeDuplicated l =
        case l
         of [] => []
          | x :: xs => 
            if List.exists (fn y => Id.equals (x, y)) xs
            then removeDuplicated xs
            else x :: (removeDuplicated xs)
        
    fun orig (T {stms, ...}) =
        List.concat (List.map (Stm.orig) stms)
*)    
    fun successors (T {successors, ...}) = successors
    

(*   
    fun toStringDot x =
        case x
          of T {name,prop,stms,transfer,successors}  =>
              String.concat [Id.toString name, "\\n",
                             printListDot (stms,";\\n",Stm.toString),
                             Transfer.toString transfer]
                             
    fun stms (T {stms, ...}) = stms
*)
    fun toString x =
        case x
          of T {name,prop,stms,transfer,successors}  =>
              String.concat [Id.toString name, "\\n",
                             printListDot (stms,";\\n",Stm.toString),
                             Transfer.toString transfer]
  end

  structure Structs =
  struct
    datatype t
      = T of {name : Id.t,
              fields : {id : Id.t, ty : Types.t} list}

    fun bogus () = T {name = Id.bogus (), fields = []}
    fun equals (s1, s2) = raise Fail "bogus"

    fun toString x =
        case x
          of T {name, fields, ...} =>
            String.concat ["struct ", Id.toString name, " {",
                           listFields fields, "}; "]
  end

  structure Function =
  struct
    datatype t
      = T of {name : Id.t,
              exit : Id.t,
              rettype : Types.t,
              args : {id : Id.t, loc : Location.t, ty : Types.t} list,
              locals : {id : Id.t, loc : Location.t, ty : Types.t} list,
              stackSize : Intl.t,
              blocks : Block.t list,
              pre : Operand.t,
              post : Operand.t}

(*    
    fun addBlock (t, b) =
        case t
         of T {name,
                exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
            T {name = name,
                exit = exit,
                rettype = rettype,
                args = args,
                locals = locals,
                blocks = b :: blocks,
                pre = pre,
                post = post}
*)          
    fun blocks (T {blocks, ...}) = blocks
    
    fun name (T {name, ...}) = name
    
    val stringName = Id.toString o name

    
    structure Map =
    BinaryMapFn (struct
                   type ord_key = Id.t
                   val compare = Id.compare
                 end)
                 
    val refMap : unit DiGraph.Node.t Map.map ref = ref Map.empty
    val refMapInit = fn () => refMap := Map.empty
    fun lookup id =
        case Map.find (!refMap, id)
         of NONE => (debugPrint (String.concat ["not found: ", Id.toString id])
                 ; raise Fail "compiler bug")
          | SOME v => v
    fun enter (id, b) = refMap := Map.insert (!refMap, id, b)
                 
    val {get = getBlock, set = setBlock, destroy = destBlock, ...} :
        {get : unit DiGraph.Node.t -> Block.t option,
         set : unit DiGraph.Node.t * Block.t option -> unit,
         destroy : unit -> unit} =
        Property.destGetSet (DiGraph.Node.plist, Property.initConst NONE)
(*        
    val {get = getName, set = setName, destroy = destName, ...} :
        {get : unit DiGraph.Node.t -> Id.t option,
         set : unit DiGraph.Node.t * Id.t option -> unit,
         destroy : unit -> unit} =
        Property.destGetSet (DiGraph.Node.plist, Property.initConst NONE)    
     
    val {get = getDf, set = setDf, destroy = destDf, ...} :
        {get : unit DiGraph.Node.t -> unit DiGraph.Node.t list,
         set : unit DiGraph.Node.t * unit DiGraph.Node.t list -> unit,
         destroy : unit -> unit} =
        Property.destGetSet (DiGraph.Node.plist, Property.initConst [])   
        
   
        

        
    fun setNameGraph t =
        let val g = DiGraph.new ()
            val _ = refMapInit ()
            val blocks = blocks t
            fun addAllNodes ns =
                case ns
                 of [] => ()
                  | x :: xs =>
                    let val name = Block.name x
                        val node = DiGraph.newNode g
                        val _ = setName (node, SOME name)
                        val _ = enter (name, node)
                    in  addAllNodes xs
                    end
            val _ = addAllNodes blocks
            fun addSuccessors (id, succs) =
                case succs
                 of [] => ()
                  | x :: xs =>
                    let val _ = DiGraph.addEdge (g, {from = lookup id, to = lookup x})
                    in  addSuccessors (id, xs)
                    end
            fun addAllEdges es =
                case es
                 of [] => ()
                  | x :: xs =>
                    let val name = Block.name x
                        val successors = Block.successors x
                        val _ = addSuccessors (name, successors)
                    in  addAllEdges xs
                    end
            val _ = addAllEdges blocks
            fun findLabel id =
                let val nodes = DiGraph.nodes g
                    fun doit l =
                        case l
                         of [] => raise Fail "compiler bug"
                          | x :: xs =>
                            let val idOfNode = valOf (getName x)
                            in  if Id.equals (id, idOfNode)
                                then x
                                else doit xs                        
                            end
                in  doit nodes
                end
        in  {graph = g, getName = valOf o getName, labelNode = findLabel}
        end
        
    fun fromGraph g =
        let val nodes = DiGraph.nodes g
            val blocks = List.map (valOf o getBlock) nodes
        in  blocks
        end
    
    fun df t =
        let val g = toGraph t
            val start = lookup (name t) 
            val _ = DiGraph.calculateDf (g, start, getDf, setDf, Id.toString o Block.name o valOf o getBlock)
        in  {graph = g,
             getDf = getDf}
        end
        
    fun reachable (t, start) =
        let val {graph, getName, labelNode, ...} = setNameGraph t
            val start = labelNode start
            val l = DiGraph.reachable (graph, start)
            val l = List.map getName l
        in  l
        end
        
    fun ssaUtil t =
        let val _ = debugPrint "ssaUtil starting\n"
            val g = toGraph t
            val start = lookup (name t)
            val _ = debugPrint "calculate df starting\n"
            val _ = DiGraph.calculateDf (g, start, getDf, setDf, Id.toString o Block.name o valOf o getBlock)
            val _ = debugPrint "calculate df finished\n"
            fun findLabel id =
                let val nodes = DiGraph.nodes g
                    fun doit l =
                        case l
                 of [] => raise Fail "compiler bug"
                  | x :: xs =>
                    let val idOfNode = Block.name (valOf (getBlock x))                     
                    in  if Id.equals (id, idOfNode)
                        then x
                        else doit xs                        
                    end
                in  doit nodes
                end
            val _ = debugPrint "ssaUtil finished\n"
        in  {graph = g,
             getBlock = getBlock,
             setBlock = setBlock,             
             getDf = getDf,
             labelNode = findLabel,
             getName = Block.name o valOf o getBlock}
        end
        
    fun toReverseGraph x =
        let val {graph, getName, ...} = setNameGraph x
            val _ = debugPrint "after set name in cfg.fun\n"
            val debug = Id.toString o getName
            val {graph, getLabel, ...} = DiGraph.reverse (graph, getName, Id.equals, debug)
        in  {graph = graph, getName = getLabel}
        end
        
        

        
    fun reverseGraphToDot (x, str) =
        let val {graph, getName, ...} = toReverseGraph x
            val _ = DiGraph.toDot (graph, str, Id.toString o getName)
        in  ()
        end
        
    fun dfs t =
        let val g = toGraph t
            val start = lookup (name t)
            val _ = DiGraph.dfs (g, start, print o (Id.toString o (Block.name o (valOf o getBlock))))
        in  ()
        end
        
    fun dfsTree t =
        let val g = toGraph t
            val start = lookup (name t)
            val tree = DiGraph.dfsTree (g, start, valOf o getBlock)
        in  tree
        end
        
    fun dominatorTree t =
        let val g = toGraph t
            val start = lookup (name t)
            val tree = DiGraph.dominatorTree (g, start, valOf o getBlock,
                                              Id.toString o Block.name o valOf o getBlock)
            fun findLabel lab =
                let val nodes = Tree.nodes tree
                    fun doit l =
                        case l
                         of [] => raise Fail "compiler bug"
                          | x :: xs =>
                            let val m = Tree.Node.content x
                                val name = Block.name m
                            in  if Id.equals (lab, name)
                                then List.map (Block.name o Tree.Node.content) (Tree.Node.successors x)
                                else doit xs
                            end
               in   doit nodes
               end
        in  {tree = tree,
             labelTreeNode = findLabel}
        end
        
    fun toDotDomTree t =
        let val {tree, ...} = dominatorTree t
            val name = String.concat [Id.toString (name t), "domTree"]
            val toString = Block.toStringDot o Tree.Node.content
            val _ = Tree.toDot (tree, name, toString)
        in  ()
        end
        
    fun toDotTree x =
        let val tree = dfsTree x
            val name = String.concat [Id.toString (name x), "dfsTree"]
            val toString = Block.toStringDot o Tree.Node.content
            val _ = Tree.toDot (tree, name, toString)
        in  ()
        end
 *)       
    fun toString x =
        case x
          of T {name,
                exit,
                rettype,
                args,
                locals,
                stackSize,
                blocks,
                pre,
                post} =>
             String.concat ["pre-condition::", Operand.toString pre,"\n",
                            Types.toString rettype, " ",
                            Id.toString name,
                            "(", listArgs args, "){",
                            "\n", listLocals locals,
                            "\nstackSize = ", Intl.toString stackSize,
                            "\n", printList (blocks,"\n",Block.toString),
                            "\n}\npost-condition::", Operand.toString post]
   (*                         
    fun isEmptyBlock (x, id) =
        case x
          of T {name,
                exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
             let fun doit bs =
                     case bs
                      of [] => raise Fail "compiler bug"
                       | x :: xs =>
                         if Id.equals (Block.name x, id)
                         then case Block.stms x
                               of [] =>
                                  (case Block.successors x
                                    of [] => NONE
                                     | [next] => SOME next
                                     | _ => NONE)
                                | _ => NONE
                         else doit xs
             in  doit blocks
             end   
*)
    fun toGraph x =
        let val g = DiGraph.new ()
            val _ = refMapInit ()
            val blocks = blocks x
            fun addAllNodes ns =
                case ns
                 of [] => ()
                  | x :: xs =>
                    let val name = Block.name x
                        val node = DiGraph.newNode g
                        val _ = setBlock (node, SOME x)
                        val _ = enter (name, node)
                    in  addAllNodes xs
                    end
            val _ = addAllNodes blocks
            fun addSuccessors (id, succs) =
                case succs
                 of [] => ()
                  | x :: xs =>
                    let val _ = DiGraph.addEdge (g, {from = lookup id, to = lookup x})
                    in  addSuccessors (id, xs)
                    end
            fun addAllEdges es =
                case es
                 of [] => ()
                  | x :: xs =>
                    let val name = Block.name x
                        val successors = Block.successors x
                        val _ = addSuccessors (name, successors)
                    in  addAllEdges xs
                    end
            val _ = addAllEdges blocks
        in  g
        end
        
    fun toDot (x, ss) =
        let val g = toGraph x
            val toString =
                Block.toString o (valOf o getBlock)
            val _ = DiGraph.toDot (g, ss, toString)
        in  ()
        end
  end

  structure Program =
  struct
    datatype t
      = T of {structs : Structs.t list,
              gvars : {id : Id.t, ty : Types.t} list,
              funcs : Function.t list}

(*
    val bogus = fn _ => raise Fail "bogus"
    

    
    fun reverseToDot (f, str) = List.app (fn x => Function.reverseGraphToDot (x, 
                                String.concat [Id.toString (Function.name x), str]))
                             (funcs f)
                                 

*)    
    fun toString x =
        case x
         of T {funcs, ...} =>
            let fun listFuns l =
                case l
                 of [] => ""
                  | x :: xs => String.concat [Function.toString x, "\n",
                                              listFuns xs]
            in  listFuns funcs
            end

    fun funcs f =
        case f
         of T {funcs, ...} => funcs
         
    fun toDot (f, str) = List.app (fn x => Function.toDot (x, 
                                String.concat [Id.toString (Function.name x), str]))
                             (funcs f)
  end
end
